home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.0-b / stk-3 / blt-for-STk-3.0 / Demos / calendar.stk < prev    next >
Encoding:
Text File  |  1995-12-28  |  2.5 KB  |  84 lines
  1. ;;; Don't try this program a February 29!!!!!!!
  2.  
  3. (set! *load-path* (cons ".." *load-path*))
  4. (require "blt")
  5. (require "hash")
  6.  
  7. (option 'add "*Calendar.Frame.borderWidth"    2)
  8. (option 'add "*Calendar.Frame.relief"        "raised")
  9. (option 'add "*Calendar.Label.font"         "*-Helvetica-Bold-R-*-14-*")
  10. (option 'add "*Calendar*background"         "steelblue")
  11. (option 'add "*Calendar*foreground"        "white")
  12.  
  13. (define monthinfo '((Jan "January" 31)
  14.             (Feb "February" 28)
  15.             (Mar "March" 31)
  16.             (Apr "April" 30)
  17.             (May "May" 31)
  18.             (Jun "June" 30)
  19.             (Jul "July" 31)
  20.             (Aug "August" 31)
  21.             (Sep "September" 30)
  22.             (Oct "October" 31)
  23.             (Nov "November" 30)
  24.             (Dec "December" 31)))
  25.  
  26. (define abbrDays '(Sun Mon Tue Wed Thu Fri Sat))
  27.  
  28. (define (Calendar weekday month day)
  29.   (let ((wkdayOffset (- 7 (length (member weekday abbrDays))))
  30.         (dayOffset   (modulo (- day 1) 7))
  31.     (info         (assoc month monthinfo))
  32.     (wkday         0))
  33.  
  34.     (if (< wkdayOffset dayOffset) (set! wkdayOffset (+ 7 wkdayOffset)))
  35.  
  36.     ;; Title
  37.     (frame '.calendar :class "Calendar")
  38.     (label '.calendar.month :text (cadr info)
  39.                    :font "*-New*Century*Schoolbook-Bold-R-*-18-*")
  40.     (blt_table .calendar .calendar.month "1,1" :cspan 7)
  41.  
  42.     ;; Week days label
  43.     (frame '.calendar.weekframe :relief "sunken" :bd 2)
  44.     (blt_table .calendar .calendar.weekframe "2,0" :columnspan 8 :fill "both")
  45.  
  46.     (let loop ((cnt 1) (days abbrDays))
  47.       (let ((widget-name (& .calendar "." (car days))))
  48.     (label widget-name :text (car days) 
  49.                       :font "*-New*Century*Schoolbook-Bold-R-*-14-*")
  50.      (blt_table .calendar widget-name 
  51.             (format #f "2,~s" cnt) :pady 2 :padx 2)
  52.      (if (< cnt 7) (loop (+ cnt 1) (cdr days)))))
  53.  
  54.     (blt_table 'column .calendar 'configure 'all :padx 4)
  55.     (blt_table 'column .calendar 'configure 0 :width 0)
  56.     (blt_table 'row .calendar 'configure 2 :pady 4)
  57.  
  58.     ;; Days
  59.     (do ((week 0)(numdays (caddr info))
  60.      (cnt 1 (+ cnt 1)) 
  61.      (wkday  (+ 1 (- wkdayOffset dayOffset)) (+ wkday 1)))
  62.     ((> cnt numdays))
  63.       
  64.       (label (& ".calendar.day" cnt):text cnt :bd 3 :relief (if (= cnt day)
  65.                                 "ridge"
  66.                                 "flat"))
  67.       (blt_table .calendar (& ".calendar.day" cnt) 
  68.          (format #f "~A,~A" (+ week 3) wkday)
  69.          :fill "both")
  70.  
  71.       (when (= wkday 7)
  72.      (set! week (+ week 1))
  73.      (set! wkday 0)))
  74.     
  75.     (pack .calendar :expand #t :fill "both")))
  76.  
  77. (wm 'minsize *root* 0 0)
  78. (wm 'maxsize *root* 1000 1000)
  79.  
  80. (with-input-from-file "| date" (lambda () (Calendar (read) (read) (read))))
  81.  
  82.  
  83.  
  84.